home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4th86_v4.zip / ARRAY.4TH < prev    next >
Text File  |  1994-01-01  |  6KB  |  191 lines
  1. ( forget strt
  2. : strt ; )
  3. off printload 
  4. unsplit
  5.  
  6. ( **************************************************** )
  7. ( * this file contains an example of a defining word * )
  8. ( *                                                  * )
  9. ( * source  extended  from the original CP/M80       * )
  10. ( **************************************************** )
  11.  
  12.  
  13. ( 
  14. * Most FORTH words execute some function -- such as drawing a line;
  15. *  storing a variable in memory; saving a file etc.
  16. *
  17. *  COMPILER WORDS are different in that their effect is to extend the
  18. *  scope of the FORTH interpreter itself by creating ( or part creating )
  19. *  a new word.
  20. *
  21. *  The existing words CODE; CONSTANT; BLOCK; -- and of course the colon
  22. *  and semicolon that start and end all definitions -- are compiler words.
  23. *
  24. *  What this file does is illustrate how to write your own compiler words.
  25. *  The word chosen is ARRAY -- which functions in much the same manner as 
  26. *  BLOCK.
  27. *
  28. *    2 BLOCK FRED  for example creates a storage are of 2 bytes which 
  29. *  is accessible by the name FRED.
  30. *
  31. *       3 4 ARRAY KEN  will be a word which creates a storage area of
  32. *  ( 3 x 4 ) = 12 bytes-pairs [ ie 16 bits ]  -- and allows cells to be 
  33. *  read again by a command such as   2 3 KEN @
  34. *
  35. *  The defined word, when executed, returns the address
  36. *  of specified cell (tos is row, nos is column)
  37. *  Each cell is 16 bits.  For example,
  38. *
  39. *        8 3 ARRAY XYZ   ( 3 rows (0 to 2), 8 columns (0 to 7))
  40. *        0 4 0 XYZ !     ( store 0 in 0th row, 4th column)
  41. *        7 2 XYZ @       ( fetch last cell in array)
  42. *
  43. *  No error checking at compile time or run time, add it if needed.
  44. * 
  45. *
  46. * ARRAY designed to build the following code:
  47. *        CALL xarray   ;call runtime, tos will have adr of dw's
  48. *        DW   base     ;base of data space allocated
  49. *        DW   #rows-1
  50. *        DW   #cols-1  
  51. * )
  52.  
  53. : ARRAY ( col row -- word)
  54.   0 DEFINE  ( put name in dictionary)
  55.   e8H HEADB! ( opcode for CALL )
  56.  
  57.   ' XARRAY   ( XARRAY not defined yet - no problem though as 
  58.               in high mode, tick (') does not try to look up
  59.           the address of following word.  Instead, it 
  60.               stores text string "XARRAY" in-line so word can 
  61.           be looked up ( in the appropriate dictionary ) when 
  62.           ARRAY executes )
  63.  
  64.   head @ 2+ - HEAD! ( relative call address of XARRAY )
  65.  
  66.   OVER OVER * 2 * LUM @ SWAP - DUP LUM ! ( alloc memory)
  67.   HEAD! ( store base address after call)
  68.   HEAD! ( store number rows) ( for later error checking)
  69.   2 * HEAD! ( store # bytes/row )
  70. ; IMMEDIATE
  71.  
  72.  
  73. ( ---------------------------------------------------- )
  74.                ( run time for ARRAY)
  75.  
  76. (
  77. * this is comparable to the exiting words VLOAD, LVLOAD etc. It
  78. *  extracts the address pointer to the data from the array.
  79. )
  80.  
  81. : XARRAY ( col row -- adr)
  82.   SWAP OVER 4 + @ ( get 'column*2' dimension)
  83.   * ( offset to correct row)
  84.   SWAP @ ( get array base adr) + ( baseadr + rowofset)
  85.   SWAP DUP + ( column offset) + ( got adr of cell)
  86. ;
  87.  
  88. (    **** NOTE *** 
  89.  
  90. *  If you are creating a standalone turnkey COM file that uses the word
  91. *  ARRAY - then it must be pre-loaded into the "mother" system you are 
  92. *  using to cross-compile the standalone COM file. 
  93. *
  94. *  While it is **NOT** needed in the actual standalone COM file ( Only the 
  95. *  routine XARRAY is needed there ) it will do no harm to include it.
  96. *
  97. *  You will need XARRAY in the mother system as well as ARRAY to be able 
  98. *  to use ARRAY during [ non cross compile ] development and debugging.
  99. )
  100.  
  101. ( ---------------------------------------------------- )
  102.  
  103. on printload
  104. cls
  105.  
  106. ( Following is an illustration of the use of ARRAY 
  107.  
  108. The word SHOWCALENDAR is used to display dates against days.
  109.     It takes two parameters --  X Y SHOWCALENDAR
  110. where X is a number from 0 through 6 to represent the starting day
  111.       Y is a number from 28 through 31 to represent the days in the month
  112.  
  113.      so  4 30 SHOWCALENDAR will display 30 days starting on Wednesday )
  114.  
  115. off printload
  116.  
  117. ( ** NOTE ** there is no check on the values of X and Y inserted. Impossible 
  118. values such as days > 31 or starting day > 6 will be accepted. Modify as you 
  119. wish to check the  input parameters for valid range )
  120.  
  121. : HEADER  crlf "  Su  Mo  Tu  We  Th  Fr  Sa  " ." crlf
  122.            " ============================ " ."  ;
  123.  
  124.   7 5 array calendar
  125.   2 block startday
  126.   2 block maxdate
  127.  
  128. ( ***********
  129.   fill array with  numbers 0 through maxdate
  130.   fill actually starts with a negative value ( 0 - startdate )
  131.   and where a negative value would have been inserted, 40 is inserted
  132.   instead. [ 40 is arbitrary - any number greater than 31 will do ]
  133.    40 is treated specially in SHOWC which follows
  134.   *********** )
  135.  
  136. : fillc 0 startday @ -  
  137.           4 0                 ( rows ) 
  138.             do 6 0             ( columns ) 
  139.             │   do 1+ dup 
  140.         │   │    dup 1 <         ( previous month )
  141.         │   │  if          
  142.         │   │  │   drop 40         ( so put in a 40 )
  143.         │   │ then 
  144.         │   │   i j  calendar ! 
  145.         │  loop 
  146.            loop   drop ;
  147.  
  148.         
  149. ( ***********
  150.   fill array with  
  151.   arbitrary value 40
  152.   *********** )
  153.  
  154. : clear 4 0 
  155.     do 6 0 
  156.     │    do  
  157.         │    │ 40 i j calendar ! 
  158.         │   loop 
  159.        loop ;
  160.  
  161. ( ***********
  162.   display array on screen
  163.   *********** )
  164.  
  165. : showc 4 0                     ( rows )
  166.     do crlf 6 0                 ( columns )
  167.     │    do i j calendar @ dup 10 <  
  168.     │    │  if 
  169.         │    │  │ 1 spcs       ( extra leading space for single digits )
  170.         │    │ then dup maxdate @  > 
  171.         │    │    if 
  172.         │    │       │  2 spcs drop 0 .c 1 spcs ( print blank space character )
  173.         │    │    else 
  174.         │    │    │ . 1 spcs        ( print valid date )
  175.         │    │    then    
  176.         │   loop 
  177.        loop ;
  178.  
  179. ( ***********
  180.   main routine
  181.   *********** )
  182.  
  183. : showcalendar maxdate ! startday ! 
  184.         clear header fillc showc ;
  185.  
  186. " __________________________________________________________ " ." crlf crlf
  187. "                                  3 30 showcalendar " ."
  188. 3 30 showcalendar crlf crlf crlf
  189.  
  190.  
  191.